#! /usr/bin/env perl
##
## Copyright (C) by Argonne National Laboratory
##     See COPYRIGHT in top-level directory
##

use warnings;
use strict;
use File::Basename;

my $debug = 0;
my $cur_dir = "src/binding/fortran/use_mpi_f08";
my $wrappers_f_dir = "wrappers_f";
my $pmpi_dir = "wrappers_f/profiling";

# Stage 1: Translate mpi_f08.f90 into pmpi_f08.f90
# =====================================================================

# replaced with gen_binging_f08.py

# Stage 2: Translate Fortran MPI wrapper files into PMPI wrapper files
# =====================================================================

# replaced with gen_binging_f08.py

# Stage 3: Generate Makefile.mk under use_mpi_f08
# =====================================================================

# replaced with gen_binging_f08.py

# Stage 4: Generate mpi_f08_compile_constants.f90.in
# =====================================================================

# Some of the following variables and subroutines are adapted from F77
# buildiface. They are used to parse files like mpi.h.in and mpio.h.in,
# store MPI definitions and print them in Fortran source code.
# The main driver part follows the subroutines.

my %mpidef; # Map MPI constant names to values
my %mpidefFile;
my $build_io = 1;
my %skipBlocks;

my $constants_file = "mpi_f08_compile_constants.f90.in.new";
my $constants_fh; # File handle of $constants_file

# Skip ifndef'ed blocks
sub SkipCPPIfdef {
    my $FD = $_[0];
    my $depth = 1;

    while (<$FD>) {
        if (/^#\s*endif/) {
            $depth--;
            #print "Depth is now $depth\n";
        }
        elsif (/^#\s*if/) {
            $depth++;
            #print "Depth is now $depth\n";
        }
        #print "Skipping $_";
        if ($depth <= 0) { last; }
    }
    return 0;
}

# Parse an interface file
sub ReadInterfaceForDefinitions {
    my $prototype_file = $_[0];
    my $linecount = 0;
    my $prototype_fh;

    open ($prototype_fh, "<$prototype_file" ) || die "Could not open $prototype_file\n";
    #
    # First, find the values that we need
    while (<$prototype_fh>) {
        $linecount++;
        # Remove any comments; check for problems
        my $origline = $_;
        while (/(.*)\/\*(.*?)\*\/(.*)/) {
            my $removed = $2;
            $_ = $1.$3;
            if ($2 =~ /\/\*/) {
                print STDERR "Error in processing comment within interface file $prototype_file in line $origline";
            }
        }

        # We should also skip #ifndef xxx, for some xxx.
        if (/^#\s*ifndef\s+(\w*)/) {
            my $ndefname = $1;
            if (defined($skipBlocks{$ndefname})) {
                &SkipCPPIfdef($prototype_fh);
            }
        }

        # Use \S instead of [^\s].  See the comment above
        if (/^\s*#\s*define\s+(MPI[X]*_[A-Za-z_0-9]*)\s+(\S+)(.*)/) {
            my $name      = $1;
            my $val       = $2;
            my $remainder = $3;
            print "Found definition of $name as $val\n" if $debug;
            # If the name has some lower case letters in it, we
            # need to skip it (e.g., for a define MPI_Comm_c2f...)
            if ($name =~ /[a-z]/) { next; }
            if (defined($mpidef{$name})) {
                # We want to catch the case ((cast) value).  In
                # The above definition, the space will break the
                # value into the cast (actually, "((cast)").
                my $fullval = "$val $remainder";
                if ($fullval =~ /\(\(([^\(\)]*)\)\s*([^\(\)]*)\s*\)/) {
                    $val = "(($1)$2)";
                }
                if ($mpidef{$name} ne $val) {
                    my $found = "";
                    if (defined($mpidefFile{$name})) {
                        my $location = $mpidefFile{$name};
                        $found = " found in $location";
                    }
                    print STDERR "Attempting to redefine $name with a new value $val found in \
                        $prototype_file:$linecount,\nusing original value of $mpidef{$name}$found\n";
                }
            } else {
                $mpidef{$name} = $val;
                $mpidefFile{$name} = "$prototype_file:$linecount";
            }
        }
        elsif (/typedef\s+enum\s+[A-Za-z0-9_]*\s*{\s*(.*)/) {
            # Allow a named type
            # Eat until we find the closing right brace
            my $enum_line = $1;
            while (! ($enum_line =~ /}/)) {
                my $newline = <$prototype_fh>;
                $newline =~ s/\r*\n//;
                $enum_line .= $newline;
                $linecount++;
            }
            print "Handling enum $enum_line...\n" if $debug;
            # Now process for names and values
            while (($enum_line =~ /\s*(MPI[X]*_[A-Z_0-9]*)\s*=\s*([a-fx0-9]*)(.*)/)) {
                $mpidef{$1} = $2;
                $mpidefFile{$1} = "$prototype_file:$linecount";
                $enum_line = $3;
                print "Defining $1 as $2\n" if $debug;
            }
        }
        elsif (/enum\s+([A-Za-z0-9_]*)\s*{\s*(.*)/) {
            # Allow a named type
            # Eat until we find the closing right brace
            my $enum_name = $1;
            my $enum_line = $2;
            while (! ($enum_line =~ /}/)) {
                print "reading for $enum_name...\n" if $debug;
                my $newline = <$prototype_fh>;
                $newline =~ s/\r*\n//;
                $enum_line .= $newline;
                $linecount++;
            }
            # Now process for names and values
            while (($enum_line =~ /\s*(MPI[X]*_[A-Z_0-9]*)\s*=\s*([a-fx0-9]*)(.*)/)) {
                my $name = $1;
                my $val = $2;
                my $remainder = $3;
                $mpidef{$name} = $val;
                $mpidefFile{$name} = "$prototype_file:$linecount";
                $enum_line = $remainder;
                print "Defining $name as $val\n" if $debug;
            }
        }
    } # ~while (<$prototype_fh>)
    close ($prototype_fh);
}

# Print a Fortran parameter
sub print_param {
    my $type = $_[0]; # type can be integer or other MPI_F08 types like MPI_Op
    my $key = $_[1];  # MPI constants, like MPI_COMM_WORLD
    my $value = $mpidef{$key};
    my $hexvalue = "";

    if (!defined($value) || $value eq "") {
        print STDERR "No value found for \"$key\"\n";
        return 0;
    }
    # Remove any casts
    print "Input value for $key = $value\n" if $debug;
    # Add a special case to for MPIX_*
    if ($value =~ /\(MPIX/) {
        $value =~ s/\(MPIX_[A-Za-z0-9]*\s*\)//;
        print "cast removal: $value\n" if $debug;
        # Remove any surrounding (MPI_REQUEST_NULL)
        if ($value =~ /\(\s*[A-Z_]*\)/) {
            $value =~ s/\(\s*([A-Z_]*)\s*\)/$1/;
            print "paren removal: $value\n" if $debug;
        }
    }
    if ($value =~ /\(MPI/) {
        $value =~ s/\(MPI_[A-Za-z0-9]*\s*\)//;
        print "cast removal: $value\n" if $debug;
    }
    # Remove any surrounding () around numbers or placeholders like @MPI_COMPLEX@
    if ($value =~ /\(\s*[-a-fx0-9\w@]*\)/) {
        $value =~ s/\(\s*([-a-fx0-9\w@]*)\s*\)/$1/;
        print "paren removal: $value\n" if $debug;
    }
    # Convert hex to decimal
    if ($value =~ /^0x[a-f\d]*/) {
        $hexvalue = $value; # remember hex value for better output
        $value = hex $value;
        print "hex conversion: $value\n" if $debug;
    }

    if ($type =~ /integer/) {
        printf $constants_fh ("$type, parameter :: %-32s = %s", $key, $value);
    } else { # Fortran derived data types
        my $typestr = $type;
        my $valuestr = $value;
        $typestr = "type($type)";
        $valuestr = "$type($value)";
        printf $constants_fh ("%-31s :: %-19s = %s", "$typestr, parameter", $key, $valuestr);
    }

    # Print the old hex value (if it was) as comments for readability
    if ($hexvalue) { printf $constants_fh " ! $hexvalue"; }
    printf $constants_fh "\n";
}


# Replace old file with new file only if new file is different
# Otherwise, remove new filename
sub ReplaceIfDifferent {
    my ($oldfilename,$newfilename) = @_;
    my $rc = 1;
    if (-s $oldfilename) {
        $rc = system "cmp -s $newfilename $oldfilename";
        $rc >>= 8;   # Shift right to get exit status
    }
    if ($rc != 0) {
        # The files differ.  Replace the old file
        # with the new one
        if (-s $oldfilename) {
            print STDERR "Replacing $oldfilename\n";
            unlink $oldfilename;
        }
        else {
            print STDERR "Creating $oldfilename\n";
        }
        rename $newfilename, $oldfilename || die "Could not replace $oldfilename";
    } else {
        unlink $newfilename;
    }
}


# Main driver to generate mpi_f08_compile_constants.f90.in

&ReadInterfaceForDefinitions("../../../include/mpi.h.in");
if ( -s "../../../mpi/romio/include/mpio.h.in" && $build_io) {
    %skipBlocks = ('HAVE_MPI_DARRAY_SUBARRAY' => 1,
                   'HAVE_MPI_INFO' => 1,
                   'MPICH' => 1);
    &ReadInterfaceForDefinitions( "../../../mpi/romio/include/mpio.h.in" );
    %skipBlocks = ();
} else {
    $build_io = 0;
}

open($constants_fh, ">", $constants_file) || die "Error: Could not open $constants_file, $!";
print $constants_fh <<EOT;
!
! Copyright (C) by Argonne National Laboratory
!     See COPYRIGHT in top-level directory
!

module mpi_f08_compile_constants

use,intrinsic :: iso_c_binding, only: c_int
use :: mpi_f08_types
use :: mpi_c_interface_types, only: c_Aint, c_Count, c_Offset

!====================================================================
! Make names brought in from other modules private if they should not
! be exposed in program units using this module
!====================================================================

! Make names from iso_c_binding private
private :: c_int

! Make names from mpi_c_interface_types private
private :: c_Aint
private :: c_Count
private :: c_Offset

EOT

my $key;

# version
print $constants_fh "\n! MPI version\n";
&print_param("integer", "MPI_VERSION");
&print_param("integer", "MPI_SUBVERSION");

# Error classes
print $constants_fh "\n! Error classes\n";
$mpidef{"MPI_SUCCESS"} = 0;
&print_param("integer", "MPI_SUCCESS");
my %errors; # To print error classes in ascending order for readability
foreach $key (keys(%mpidef)) {
    my $val;
    if ($key =~ /MPI_ERR_/) {
        if ($mpidef{$key} =~ /^0x[a-f\d]*/) { $val = hex($mpidef{$key}); }
        else { $val = $mpidef{$key}; }
        $errors{$key} = $val;
    }
}
foreach $key (sort { $errors{$a} <=> $errors{$b} } keys %errors) {
    &print_param("integer", $key);
}

# Predefined error handlers
print $constants_fh "\n! Predefined error handlers\n";
foreach $key (qw(ERRORS_ARE_FATAL ERRORS_RETURN)) {
    &print_param("MPI_Errhandler", "MPI_$key");
}

# Compare operations
print $constants_fh "\n! Compare operations\n";
foreach $key (qw(IDENT CONGRUENT SIMILAR UNEQUAL)) {
    &print_param("integer","MPI_$key");
}

# Window flavor and model
print $constants_fh "\n! Window flavors and models\n";
foreach $key (qw(FLAVOR_CREATE FLAVOR_ALLOCATE FLAVOR_DYNAMIC FLAVOR_SHARED SEPARATE UNIFIED)) {
    &print_param("integer","MPI_WIN_$key");
}

# Collective operations
print $constants_fh "\n! Collective operations\n";
foreach $key (qw(MAX MIN SUM PROD LAND BAND LOR BOR LXOR
                 BXOR MINLOC MAXLOC REPLACE NO_OP))
{
    &print_param("MPI_Op","MPI_$key");
}

# Objects
print $constants_fh "\n! Predefined comms and null handles\n";
&print_param("MPI_Comm", "MPI_COMM_WORLD");
&print_param("MPI_Comm", "MPI_COMM_SELF");
&print_param("MPI_Comm", "MPI_COMM_NULL");
&print_param("MPI_Group", "MPI_GROUP_EMPTY");
&print_param("MPI_Group", "MPI_GROUP_NULL");
&print_param("MPI_Win", "MPI_WIN_NULL");
&print_param("MPI_File", "MPI_FILE_NULL");
&print_param("MPI_Op", "MPI_OP_NULL");
&print_param("MPI_Datatype", "MPI_DATATYPE_NULL");
&print_param("MPI_Request", "MPI_REQUEST_NULL");
&print_param("MPI_Errhandler", "MPI_ERRHANDLER_NULL");
&print_param("MPI_Info", "MPI_INFO_NULL");
&print_param("MPI_Info", "MPI_INFO_ENV");
&print_param("MPI_Message", "MPI_MESSAGE_NULL");
&print_param("MPI_Message", "MPI_MESSAGE_NO_PROC");

# Attributes
print $constants_fh "\n! Attributes\n";
foreach $key (qw(TAG_UB HOST IO WTIME_IS_GLOBAL UNIVERSE_SIZE LASTUSEDCODE APPNUM WIN_BASE
                 WIN_SIZE WIN_DISP_UNIT WIN_CREATE_FLAVOR WIN_MODEL))
{
    # Special cast:  The Fortran versions of these attributes have
    # value 1 greater than the C versions
    my $attrval = $mpidef{"MPI_$key"};
    print "$key is $attrval\n" if $debug;
    if ($attrval =~ /^0x/) { $attrval = hex $attrval; }
    $attrval++;
    $attrval = "0x" . sprintf "%x", $attrval;
    print "$key is now $attrval\n" if $debug;
    $mpidef{"MPI_$key"} = $attrval;
    &print_param("integer", "MPI_$key");
}

# String sizes
print $constants_fh "\n! String sizes\n";
foreach $key (qw(MAX_ERROR_STRING MAX_PORT_NAME MAX_OBJECT_NAME MAX_INFO_KEY MAX_INFO_VAL
                 MAX_PROCESSOR_NAME MAX_DATAREP_STRING MAX_LIBRARY_VERSION_STRING))
{
    # See MPI-2 2.6.2 and 4.12.9; the constants for string lengths are
    # defined as one less than the C/C++ version
    &print_param("integer", "MPI_$key", -1);
}

# Predefined constants
print $constants_fh "\n! Predefined constants\n";
foreach $key (qw(UNDEFINED KEYVAL_INVALID BSEND_OVERHEAD PROC_NULL ANY_SOURCE ANY_TAG ROOT))
{
    &print_param("integer", "MPI_$key");
}

# Topology types
print $constants_fh "\n! Topology types\n";
foreach $key (qw(GRAPH CART DIST_GRAPH)) {
    &print_param("integer", "MPI_$key");
}

# Special RMA values
print $constants_fh "\n! RMA lock types\n";
&print_param("integer", "MPI_LOCK_EXCLUSIVE");
&print_param("integer", "MPI_LOCK_SHARED");

# Fortran 90 types
# MPI_INTEGER_KIND added in MPI 2.2
$mpidef{MPI_ADDRESS_KIND} = "c_Aint";
$mpidef{MPI_OFFSET_KIND} = "c_Offset";
$mpidef{MPI_COUNT_KIND} = "c_Count";
$mpidef{MPI_INTEGER_KIND} = "c_int";

# F08 specific constants
print $constants_fh "\n! F08 specific constants\n";
print $constants_fh "logical, parameter :: MPI_SUBARRAYS_SUPPORTED          = .true.\n";
print $constants_fh "logical, parameter :: MPI_ASYNC_PROTECTS_NONBLOCKING   = .true.\n";

print $constants_fh "\n";
foreach $key (qw(ADDRESS_KIND OFFSET_KIND COUNT_KIND INTEGER_KIND)) {
    &print_param("integer", "MPI_$key");
}

# Datatypes
print $constants_fh "\n! Datatypes\n";
foreach $key (qw(COMPLEX  DOUBLE_COMPLEX  LOGICAL REAL DOUBLE_PRECISION INTEGER 2INTEGER
                 2DOUBLE_PRECISION 2REAL CHARACTER))
{
    $mpidef{"MPI_$key"} = "\@F08_MPI_$key\@";
    &print_param("MPI_Datatype", "MPI_$key");
}

print $constants_fh "\n";
foreach $key (qw(BYTE UB LB PACKED
                 INTEGER1 INTEGER2 INTEGER4 INTEGER8 INTEGER16
                 REAL4 REAL8 REAL16
                 COMPLEX8 COMPLEX16 COMPLEX32
                 CHAR SIGNED_CHAR UNSIGNED_CHAR WCHAR SHORT
                 UNSIGNED_SHORT INT UNSIGNED LONG UNSIGNED_LONG
                 FLOAT DOUBLE LONG_DOUBLE LONG_LONG_INT
                 UNSIGNED_LONG_LONG LONG_LONG FLOAT_INT DOUBLE_INT
                 LONG_INT SHORT_INT 2INT LONG_DOUBLE_INT
                 INT8_T INT16_T INT32_T INT64_T
                 UINT8_T UINT16_T UINT32_T UINT64_T
                 C_BOOL C_FLOAT_COMPLEX C_COMPLEX C_DOUBLE_COMPLEX C_LONG_DOUBLE_COMPLEX))
{
    $mpidef{"MPI_$key"} = "\@F08_MPI_$key\@";
    &print_param("MPI_Datatype", "MPI_$key");
}

foreach $key (qw(AINT OFFSET COUNT))
{
    $mpidef{"MPI_$key"} = "\@F08_MPI_${key}_DATATYPE\@";
    &print_param("MPI_Datatype", "MPI_$key");
}

foreach $key (qw(CXX_BOOL CXX_FLOAT_COMPLEX CXX_DOUBLE_COMPLEX CXX_LONG_DOUBLE_COMPLEX))
{
    $mpidef{"MPI_$key"} = "\@F08_MPIR_${key}\@";
    &print_param("MPI_Datatype", "MPI_$key");
}

# Datatype combiners
print $constants_fh "\n! Datatype combiners\n";
foreach $key (qw(NAMED DUP CONTIGUOUS VECTOR HVECTOR_INTEGER HVECTOR
              INDEXED HINDEXED_INTEGER HINDEXED INDEXED_BLOCK
              STRUCT_INTEGER STRUCT SUBARRAY DARRAY F90_REAL
              F90_COMPLEX F90_INTEGER RESIZED HINDEXED_BLOCK))
{
    &print_param("integer", "MPI_COMBINER_$key");
}

# Typeclasses
print $constants_fh "\n";
foreach $key (qw(REAL INTEGER COMPLEX)) {
    &print_param("integer", "MPI_TYPECLASS_$key");
}

# RMA Asserts
print $constants_fh "\n";
foreach $key (qw(NOCHECK NOSTORE NOPUT NOPRECEDE NOSUCCEED)) {
    &print_param("integer", "MPI_MODE_$key");
}

# comm_split_types
print $constants_fh "\n";
&print_param("integer", "MPI_COMM_TYPE_SHARED");

# Thread levels
print $constants_fh "\n";
foreach $key (qw(SINGLE FUNNELED SERIALIZED MULTIPLE)) {
    &print_param("integer", "MPI_THREAD_$key");
}

# MPI-2 types: Files
if ($build_io) {
    # Modes
    print $constants_fh "\n";
    foreach $key(qw(RDONLY RDWR WRONLY DELETE_ON_CLOSE UNIQUE_OPEN
           CREATE EXCL APPEND SEQUENTIAL)) {
        &print_param("integer", "MPI_MODE_$key");
    }
    # Seek
    print $constants_fh "\n";
    foreach $key (qw(SET CUR END)) {
        &print_param("integer", "MPI_SEEK_$key");
    }
    # Order
    print $constants_fh "\n";
    foreach $key (qw(C FORTRAN)) {
        &print_param("integer", "MPI_ORDER_$key");
    }
    # direction
    print $constants_fh "\n";
    foreach $key (qw(BLOCK CYCLIC NONE DFLT_DARG)) {
        &print_param("integer", "MPI_DISTRIBUTE_$key");
    }

    print $constants_fh "\n";
    &print_param("integer(kind=MPI_OFFSET_KIND)", "MPI_DISPLACEMENT_CURRENT");
}

print $constants_fh "end module mpi_f08_compile_constants\n";
close($constants_fh);

&ReplaceIfDifferent("mpi_f08_compile_constants.f90.in", "mpi_f08_compile_constants.f90.in.new");
